home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-pgp.el.z / tm-pgp.el
Encoding:
Text File  |  1998-05-21  |  9.1 KB  |  316 lines
  1. ;;; tm-pgp.el --- tm-view internal methods for PGP.
  2.  
  3. ;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Created: 1995/12/7
  7. ;; Version: $Id: tm-pgp.el,v 7.33 1997/02/13 14:51:04 morioka Exp $
  8. ;; Keywords: mail, news, MIME, multimedia, PGP, security
  9.  
  10. ;; This file is part of tm (Tools for MIME).
  11.  
  12. ;; This program is free software; you can redistribute it and/or
  13. ;; modify it under the terms of the GNU General Public License as
  14. ;; published by the Free Software Foundation; either version 2, or (at
  15. ;; your option) any later version.
  16.  
  17. ;; This program is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;;    This module is based on 2 drafts about PGP MIME integration:
  30.  
  31. ;;    - RFC 2015: "MIME Security with Pretty Good Privacy (PGP)"
  32. ;;        by Michael Elkins <elkins@aero.org> (1996/6)
  33. ;;
  34. ;;    - draft-kazu-pgp-mime-00.txt: "PGP MIME Integration"
  35. ;;        by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp>
  36. ;;            (1995/10; expired)
  37. ;;
  38. ;;    These drafts may be contrary to each other.  You should decide
  39. ;;  which you support.  (Maybe you should use PGP/MIME)
  40.  
  41. ;;; Code:
  42.  
  43. (require 'tm-play)
  44.  
  45.  
  46. ;;; @ internal method for application/pgp
  47. ;;;
  48. ;;; It is based on draft-kazu-pgp-mime-00.txt
  49.  
  50. (defun mime-article/view-application/pgp (beg end cal)
  51.   (let* ((cnum (mime-article/point-content-number beg))
  52.      (cur-buf (current-buffer))
  53.      (p-win (or (get-buffer-window mime::article/preview-buffer)
  54.             (get-largest-window)))
  55.      (new-name (format "%s-%s" (buffer-name) cnum))
  56.      (mother mime::article/preview-buffer)
  57.      (mode major-mode)
  58.      code-converter
  59.      (str (buffer-substring beg end))
  60.      )
  61.     (set-buffer (get-buffer-create new-name))
  62.     (erase-buffer)
  63.     (insert str)
  64.     (cond ((progn
  65.          (goto-char (point-min))
  66.          (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)
  67.          )
  68.        (funcall (pgp-function 'verify))
  69.        (goto-char (point-min))
  70.        (delete-region
  71.         (point-min)
  72.         (and
  73.          (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n")
  74.          (match-end 0))
  75.         )
  76.        (delete-region
  77.         (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+")
  78.          (match-beginning 0))
  79.         (point-max)
  80.         )
  81.        (goto-char (point-min))
  82.        (while (re-search-forward "^- -" nil t)
  83.          (replace-match "-")
  84.          )
  85.        (setq code-converter
  86.          (or
  87.           (cdr (assq mode mime-viewer/code-converter-alist))
  88.           (function mime-viewer/default-code-convert-region)))
  89.        )
  90.       ((progn
  91.          (goto-char (point-min))
  92.          (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t)
  93.          )
  94.        (as-binary-process (funcall (pgp-function 'decrypt)))
  95.        (goto-char (point-min))
  96.        (delete-region (point-min)
  97.               (and
  98.                (search-forward "\n\n")
  99.                (match-end 0)))
  100.        (setq code-converter (function mime-charset/decode-buffer))
  101.        ))
  102.     (setq major-mode 'mime/show-message-mode)
  103.     (setq mime::article/code-converter code-converter)
  104.     (save-window-excursion (mime/viewer-mode mother))
  105.     (set-window-buffer p-win mime::article/preview-buffer)
  106.     ))
  107.  
  108. (set-atype 'mime/content-decoding-condition
  109.        '((type . "application/pgp")
  110.          (method . mime-article/view-application/pgp)
  111.          ))
  112.  
  113. (set-atype 'mime/content-decoding-condition
  114.        '((type . "text/x-pgp")
  115.          (method . mime-article/view-application/pgp)
  116.          ))
  117.  
  118.  
  119. ;;; @ Internal method for application/pgp-signature
  120. ;;;
  121. ;;; It is based on RFC 2015.
  122.  
  123. (defvar tm-pgp::default-language 'en
  124.   "*Symbol of language for pgp.
  125. It should be ISO 639 2 letter language code such as en, ja, ...")
  126.  
  127. (defvar tm-pgp::good-signature-regexp-alist
  128.   '((en . "Good signature from user.*$"))
  129.   "Alist of language vs regexp to detect ``Good signature''.")
  130.  
  131. (defvar tm-pgp::key-expected-regexp-alist
  132.   '((en . "Key matching expected Key ID \\(\\S +\\) not found"))
  133.   "Alist of language vs regexp to detect ``Key expected''.")
  134.  
  135. (defun mime::article/call-pgp-to-check-signature (output-buffer orig-file)
  136.   (save-excursion
  137.     (set-buffer output-buffer)
  138.     (erase-buffer)
  139.     )
  140.   (let* ((lang (or tm-pgp::default-language 'en))
  141.      (status
  142.       (call-process-region (point-min)(point-max)
  143.                    "pgp" nil output-buffer nil orig-file
  144.                    (format "+language=%s" lang)
  145.                    ))
  146.      (regexp (cdr (assq lang tm-pgp::good-signature-regexp-alist)))
  147.      )
  148.     (if (= status 0)
  149.     (save-excursion
  150.       (set-buffer output-buffer)
  151.       (goto-char (point-min))
  152.       (message
  153.        (cond ((not (stringp regexp))
  154.           "Please specify right regexp for specified language")
  155.          ((re-search-forward regexp nil t)
  156.           (buffer-substring (match-beginning 0) (match-end 0))
  157.           )
  158.          (t
  159.           "Bad signature"
  160.           )))
  161.       ))))
  162.  
  163. (defun mime-article/check-pgp-signature (beg end cal)
  164.   (let* ((encoding (cdr (assq 'encoding cal)))
  165.      (cnum (mime-article/point-content-number beg))
  166.      (rcnum (reverse cnum))
  167.      (rmcnum (cdr rcnum))
  168.      (knum (car rcnum))
  169.      (onum (if (> knum 0)
  170.            (1- knum)
  171.          (1+ knum)))
  172.      (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum)
  173.                          mime::article/content-info))
  174.      status str kbuf
  175.      (basename (expand-file-name "tm" mime/tmp-dir))
  176.      (orig-file (make-temp-name basename))
  177.      (sig-file (concat orig-file ".sig"))
  178.      )
  179.     (save-excursion
  180.       (setq str (buffer-substring
  181.          (mime::content-info/point-min oinfo)
  182.          (mime::content-info/point-max oinfo)
  183.          ))
  184.       (set-buffer (get-buffer-create mime/temp-buffer-name))
  185.       (insert str)
  186.       (goto-char (point-min))
  187.       (while (re-search-forward "\n" nil t)
  188.     (replace-match "\r\n")
  189.     )
  190.       (as-binary-output-file (write-file orig-file))
  191.       (kill-buffer (current-buffer))
  192.       )
  193.     (save-excursion
  194.       (mime-article/show-output-buffer)
  195.       )
  196.     (save-excursion
  197.       (setq str (buffer-substring
  198.          (save-excursion
  199.            (goto-char beg)
  200.            (and (search-forward "\n\n")
  201.             (match-end 0)))
  202.          end))
  203.       (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name)))
  204.       (insert str)
  205.       (mime-decode-region (point-min)(point-max) encoding)
  206.       (as-binary-output-file (write-file sig-file))
  207.       (or (mime::article/call-pgp-to-check-signature
  208.        mime/output-buffer-name orig-file)
  209.       (let (pgp-id)
  210.         (save-excursion
  211.           (set-buffer mime/output-buffer-name)
  212.           (goto-char (point-min))
  213.           (let ((regexp (cdr (assq (or tm-pgp::default-language 'en)
  214.                        tm-pgp::key-expected-regexp-alist))))
  215.         (cond ((not (stringp regexp))
  216.                (message
  217.             "Please specify right regexp for specified language")
  218.                )
  219.               ((re-search-forward regexp nil t)
  220.                (setq pgp-id
  221.                  (concat "0x" (buffer-substring-no-properties
  222.                        (match-beginning 1)
  223.                        (match-end 1))))
  224.                ))))
  225.         (if (and pgp-id
  226.              (y-or-n-p
  227.               (format "Key %s not found; attempt to fetch? " pgp-id))
  228.              )
  229.         (progn
  230.           (funcall (pgp-function 'fetch-key) (cons nil pgp-id))
  231.           (mime::article/call-pgp-to-check-signature
  232.            mime/output-buffer-name orig-file)
  233.           ))
  234.         ))
  235.       (let ((other-window-scroll-buffer mime/output-buffer-name))
  236.     (scroll-other-window 8)
  237.     )
  238.       (kill-buffer kbuf)
  239.       (delete-file orig-file)
  240.       (delete-file sig-file)
  241.       )))
  242.  
  243. (set-atype 'mime/content-decoding-condition
  244.        '((type . "application/pgp-signature")
  245.          (method . mime-article/check-pgp-signature)
  246.          ))
  247.  
  248.  
  249. ;;; @ Internal method for application/pgp-encrypted
  250. ;;;
  251. ;;; It is based on RFC 2015.
  252.  
  253. (defun mime-article/decrypt-pgp (beg end cal)
  254.   (let* ((cnum (mime-article/point-content-number beg))
  255.      (rcnum (reverse cnum))
  256.      (rmcnum (cdr rcnum))
  257.      (knum (car rcnum))
  258.      (onum (if (> knum 0)
  259.            (1- knum)
  260.          (1+ knum)))
  261.      (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum)
  262.                          mime::article/content-info))
  263.      (obeg (mime::content-info/point-min oinfo))
  264.      (oend (mime::content-info/point-max oinfo))
  265.      )
  266.     (mime-article/view-application/pgp obeg oend cal)
  267.     ))
  268.  
  269. (set-atype 'mime/content-decoding-condition
  270.        '((type . "application/pgp-encrypted")
  271.          (method . mime-article/decrypt-pgp)
  272.          ))
  273.  
  274.  
  275. ;;; @ Internal method for application/pgp-keys
  276. ;;;
  277. ;;; It is based on RFC 2015.
  278.  
  279. (defun mime-article/add-pgp-keys (beg end cal)
  280.   (let* ((cnum (mime-article/point-content-number beg))
  281.      (cur-buf (current-buffer))
  282.      (new-name (format "%s-%s" (buffer-name) cnum))
  283.      (mother mime::article/preview-buffer)
  284.      (charset (cdr (assoc "charset" cal)))
  285.      (encoding (cdr (assq 'encoding cal)))
  286.      (mode major-mode)
  287.      str)
  288.     (setq str (buffer-substring beg end))
  289.     (switch-to-buffer new-name)
  290.     (setq buffer-read-only nil)
  291.     (erase-buffer)
  292.     (insert str)
  293.     (goto-char (point-min))
  294.     (if (re-search-forward "^\n" nil t)
  295.     (delete-region (point-min) (match-end 0))
  296.       )
  297.     (mime-decode-region (point-min)(point-max) encoding)
  298.     (funcall (pgp-function 'snarf-keys))
  299.     (kill-buffer (current-buffer))
  300.     ))
  301.  
  302. (set-atype 'mime/content-decoding-condition
  303.        '((type . "application/pgp-keys")
  304.          (method . mime-article/add-pgp-keys)
  305.          ))
  306.  
  307.      
  308. ;;; @ end
  309. ;;;
  310.  
  311. (provide 'tm-pgp)
  312.  
  313. (run-hooks 'tm-pgp-load-hook)
  314.  
  315. ;;; tm-pgp.el ends here
  316.